home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / libw.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  43KB  |  1,504 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* libw - procedures for writing (in C format) ais and tre files*/
  11.  
  12. #ifdef __GNUG__
  13. extern "C"
  14. {
  15. #include <sys/types.h>
  16. #include <sys/dir.h>
  17. }
  18. #endif
  19. #include "hdr.h"
  20. #include "vars.h"
  21. #include "libhdr.h"
  22. #include "ifile.h"
  23. #include "setp.h"
  24. #include "dbxp.h"
  25. #include "miscp.h"
  26. #include "smiscp.h"
  27. #include "chapp.h"
  28. #include "libp.h"
  29. #include "libfp.h"
  30. #include "libwp.h"
  31.  
  32. #ifdef BSD
  33. /* Needed for cleanup_files routine */
  34. #include <sys/types.h>
  35. #include <sys/dir.h>
  36. #endif
  37.  
  38. #ifdef SYSTEM_V
  39. /* Needed for cleanup_files routine */
  40. #include <fcntl.h>
  41. #include <sys/types.h>
  42. #include <sys/dir.h>
  43. #endif
  44.  
  45. #ifdef IBM_PC
  46. #include <dos.h>
  47. #include <errno.h>
  48. #endif
  49.  
  50. extern char *LIBRARY_PREFIX;
  51. extern IFILE *TREFILE, *AISFILE, *STUBFILE, *LIBFILE;
  52.  
  53. static void putdcl(IFILE *, Declaredmap);
  54. static void putlitmap(IFILE *, Symbol);
  55. static void putnod(IFILE *, char *, Node);
  56. static void putnodref(IFILE *, char *, Node);
  57. static void putint(IFILE *, char *, int );
  58. static void putlong(IFILE *, char *, long);
  59. static void putmisc(IFILE *, Symbol);
  60. static void putrepr(IFILE *, Symbol);
  61. static void putunt(IFILE *, char *, unsigned int);
  62. static void putnval(IFILE *, Node);
  63. static void putuint(IFILE *, char *, int *);
  64. static void putovl(IFILE *, Symbol);
  65. static void putsig(IFILE *, Symbol);
  66. static void putsym(IFILE *, char *, Symbol);
  67. static void putudecl(IFILE *, int);
  68. static long write_next(IFILE *);
  69. static void put_unit_unam(IFILE *, Symbol);
  70.  
  71. static void putdcl(IFILE *ofile, Declaredmap d)                        /*;putdcl*/
  72. {
  73.     Fordeclared fd;
  74.     char    *id;
  75.     Symbol    sym;
  76.     int        i, n = 0;
  77.     typedef struct {
  78.         char *iden;
  79.         short sym_seq;
  80.         short sym_unit;
  81.         short visible;
  82.     }f_dmap_s;
  83.     f_dmap_s ** dptrs;
  84.     f_dmap_s *    filedmap;
  85.     f_dmap_s *    save_filedmap;
  86.  
  87.     if (d == (Declaredmap)0) {
  88.         putnum(ofile, "putdcl-is-map-defined", 0);
  89.         return;
  90.     }
  91.     putnum(ofile, "putdcl-is-map-defined", 1); /* to indicate map defined */
  92.     n = 0; /* count number of entries where defined */
  93.     FORDECLARED(id, sym, d, fd);
  94.         n += 1;
  95.     ENDFORDECLARED(fd);
  96.     putnum(ofile, "putdcl-number-defined", n);
  97.     if (n == 0) return;
  98.     save_filedmap = filedmap = (f_dmap_s *)
  99.       ecalloct((unsigned)n, sizeof(f_dmap_s), "put-dcl-save-filedmap");
  100.     dptrs =
  101.       (f_dmap_s **) emalloct(sizeof(f_dmap_s *) * (unsigned)n, "put-dcl-dptrs");
  102.     n = 0;
  103.     FORDECLARED(id, sym, d, fd);
  104.         n++;  /* number of entries seen so far */
  105.         filedmap->iden = id;
  106.         if (sym == (Symbol) 0)
  107.             filedmap->sym_seq = filedmap->sym_unit = 0;
  108.         else {
  109.             filedmap->sym_seq = S_SEQ(sym);
  110.             filedmap->sym_unit = S_UNIT(sym);
  111.         }
  112.         filedmap->visible = IS_VISIBLE(fd);
  113.         /* now, insert pointer to new record such that ids are sorted 
  114.          * this is necessary (for debugging only!) to ensure entries appear
  115.          * in the same order each time the declared map is written
  116.          */
  117.         i = n-1;
  118.         while ( i > 0 && strcmp(filedmap->iden, dptrs[i-1]->iden) < 0) {
  119.             dptrs[i] = dptrs[i-1];
  120.             i--;
  121.         }
  122.         dptrs[i] = filedmap;
  123.         filedmap++;
  124.     ENDFORDECLARED(fd);
  125.  
  126.     /* now, write to file */
  127.     for (i = 0; i < n; i++ ) {
  128.         putstr(ofile, "str", dptrs[i]->iden);
  129.         putnum(ofile, "seq", dptrs[i]->sym_seq);
  130.         putnum(ofile, "unt", dptrs[i]->sym_unit);
  131.         putnum(ofile, "vis", dptrs[i]->visible);
  132.     }
  133.     efreet((char *)save_filedmap, "putdcl-save-filedmap");
  134.     efreet((char *) dptrs, "putdcl-dptrs");
  135. }
  136.  
  137. static void putlitmap(IFILE *ofile, Symbol sym)                /*;putlitmap*/
  138. {
  139.     /* called for na_enum to output literal map.
  140.      * The literal map is a tuple, entries consisting of string followed
  141.      * by integer.
  142.      */
  143.  
  144.     Tuple    tup;
  145.     int i, n;
  146.  
  147.     tup = (Tuple) OVERLOADS(sym);
  148.     n = tup_size(tup);
  149.     putnum(ofile, "litmap-n", n);
  150.     for (i = 1; i <= n; i += 2) {
  151.         putstr(ofile, "litmap-str", tup[i]);
  152.         putnum(ofile, "litmap-value", (int) tup[i+1]);
  153.     }
  154. }
  155.  
  156. static void putnod(IFILE *ofile, char *desc, Node node)                /*;putnod*/
  157. {
  158.     /* Write information for the node to a file (ofile)
  159.      * Since all the nodes in the tree all have the same N_UNIT value, 
  160.      * the node can be written to the file in a more compact format.
  161.      * The N_UNIT of the node itself and of its children (N_AST1...) need not
  162.      * be written out only their N_SEQ filed needs to be written out. There
  163.      * is one complication of this scheme. OPT_NODE which is (seq=1,unit=0) will
  164.      * conflict with (seq=1,unit=X)  of current unit. Therefore, in this case a 
  165.      * sequence # of -1 will signify OPT_NODE.
  166.      */
  167.  
  168.     Tuple    tup;
  169.     Fortup    ft1;
  170.     int     has_n_list = 0;
  171.     int        nk;
  172.     Node    nod;
  173.     short    fnum[24];
  174.     int        fnums = 0;
  175.     Symbol    sym;
  176.  
  177. #ifdef DEBUG
  178.     if (trapns>0 && N_SEQ(node) == trapns && N_UNIT(node) == trapnu)trapn(node);
  179. #endif
  180.     /* copy standard info */
  181.     nk = N_KIND(node);
  182.     fnum[fnums++] = nk;
  183.     fnum[fnums++] = N_SEQ(node);
  184.     if (N_LIST_DEFINED(nk)) {
  185.         tup = N_LIST(node);
  186.         if (tup == (Tuple)0) 
  187.             has_n_list = 0;
  188.         else
  189.             has_n_list = 1 + tup_size(tup);
  190.         fnum[fnums++] = has_n_list;
  191.     }
  192.     /* ast fields */
  193.     /* See comment above for description of compact format.*/
  194.     if (N_AST1_DEFINED(nk)) {
  195.         nod = N_AST1(node);
  196.         fnum[fnums++] = (N_UNIT(nod) != 0) ? N_SEQ(nod) : -1;
  197.     }
  198.     if (N_AST2_DEFINED(nk)) {
  199.         nod = N_AST2(node);
  200.         fnum[fnums++] = (N_UNIT(nod) != 0) ? N_SEQ(nod) : -1;
  201.     }
  202.     if (N_AST3_DEFINED(nk)) {
  203.         nod = N_AST3(node);
  204.         fnum[fnums++] = (N_UNIT(nod) != 0) ? N_SEQ(nod) : -1;
  205.     }
  206.     if (N_AST4_DEFINED(nk)) {
  207.         nod = N_AST4(node);
  208.         fnum[fnums++] = (N_UNIT(nod) != 0) ? N_SEQ(nod) : -1;
  209.     }
  210.     /*fnum[fnums++] = N_SIDE(node);*/
  211.     /* N_UNQ only if defined */
  212.     if (N_UNQ_DEFINED(nk))  {
  213.         sym = N_UNQ(node);
  214.         fnum[fnums++] = (sym != (Symbol)0) ? S_SEQ(sym) : 0;
  215.         fnum[fnums++] = (sym != (Symbol)0) ? S_UNIT(sym) : 0;
  216.     }
  217.     if (N_TYPE_DEFINED(nk)) {
  218.         sym = N_TYPE(node);
  219.         fnum[fnums++] = (sym != (Symbol)0) ? S_SEQ(sym) : 0;
  220.         fnum[fnums++] = (sym != (Symbol)0) ? S_UNIT(sym) : 0;
  221.     }
  222.     /* write fnums followed by fnum info as array */
  223.  
  224.     putnum(ofile, desc, fnums);
  225.     /*fwrite((char *) &fnums, sizeof(short), 1, ofile->fh_file);*/
  226.     fwrite((char *) fnum, sizeof(short), fnums, ofile->fh_file);
  227.  
  228.     /* write out n_list if needed */
  229.     if (has_n_list>1) {
  230.         tup = N_LIST(node);
  231.         FORTUP(nod = (Node), tup, ft1);
  232.             putnodref(ofile, "n-list-nodref", nod);
  233.         ENDFORTUP(ft1);
  234.     }
  235.     if (N_VAL_DEFINED(nk)) {
  236.         putnval(ofile, node);
  237.     }
  238. }
  239.  
  240. static void putnodref(IFILE *ofile, char *desc, Node node)        /*;putnodref*/
  241. {
  242.     /* OPT_NODE is node in unit 0 with sequence 1, and needs
  243.      * no special handling here
  244.      */
  245.  
  246.     if (node == (Node)0) {
  247.         putpos(ofile, "nref-seq", 0);
  248.         putunt(ofile, "nref-unt", 0);
  249.     }
  250.     else {
  251.         putpos(ofile, "nref-seq", N_SEQ(node));
  252.         putunt(ofile, "nref-unt", N_UNIT(node));
  253.     }
  254. }
  255.  
  256. static void putint(IFILE *ofile, char *desc, int n)                /*;putint*/
  257. {
  258.     /* write int to output file */
  259.  
  260.     int s = n;
  261.  
  262.     fwrite((char *) &s, sizeof(int), 1, ofile->fh_file);
  263. }
  264.  
  265. static void putlong(IFILE *ofile, char *desc, long n)                /*;putlong*/
  266. {
  267.     /* write long to output file */
  268.  
  269.     long s = n;
  270.  
  271.     fwrite((char *) &s, sizeof(long), 1, ofile->fh_file);
  272. }
  273.  
  274. static void putmisc(IFILE *ofile, Symbol sym)                /*;putmisc*/
  275. {
  276.     /* write out MISC information if present 
  277.      * MISC is integer except for package, in which case it is a triple.
  278.      * The first two components are integers, the last is  a tuple of
  279.      * symbols
  280.      */
  281.  
  282.     int    nat, i, n;
  283.     char   *m;
  284.     Tuple tup;
  285.  
  286.     nat = NATURE(sym);
  287.     m = MISC(sym);
  288.     if ((nat == na_package || nat == na_package_spec )&& m != (char *)0) {
  289.         tup = (Tuple) m;
  290.         putnum(ofile, "misc-package-1", (int)tup[1]);
  291.         putnum(ofile, "misc-package-2", (int)tup[2]);
  292.         tup = (Tuple) tup[3];
  293.         n = tup_size(tup);
  294.         putnum(ofile, "misc-package-tupsize", n);
  295.         for (i = 1; i <= n; i++)
  296.             putsymref(ofile, "misc-package-symref", (Symbol) tup[i]);
  297.     }
  298.     else if ((nat == na_procedure || nat == na_function) && m != (char *)0) {
  299.         /* misc is tuple. first entry is string, second is symbol */
  300.         tup = (Tuple) m;
  301.         putnum(ofile, "misc-number", (int) tup[1]);
  302.         putsymref(ofile, "misc-symref", (Symbol) tup[2]);
  303.     }
  304.     else {
  305.         putnum(ofile, "misc", (int)m);
  306.     }
  307. }
  308.  
  309. static void putrepr(IFILE *ofile, Symbol sym)                /*;putrepr*/
  310. {
  311.     /* write out representation  information if present */
  312.  
  313.     int    i, n;
  314.     Tuple repr_tup, tup4, align_mod_tup, align_tup;
  315.     int        repr_tag, swap_private;
  316.     Fortup    ft1;
  317.  
  318.     swap_private = FALSE;
  319.     if (is_type(sym) && !(is_generic_type(sym))) {
  320. #ifdef TBSL
  321.         if (TYPE_OF(sym) == symbol_private ||
  322.             TYPE_OF(sym) == symbol_limited_private) {
  323.              vis_decl = private_decls_get((Private_declarations)
  324.                                          private_decls(SCOPE_OF(sym)), sym);
  325.            /*
  326.             * Check to seem if vis_decl is defined before swapping it. It 
  327.             * might be undefined in the case of compilation errors.
  328.             */
  329.             if (vis_decl != (Symbol)0) {
  330.                 private_decls_swap(sym, vis_decl);
  331.                    swap_private = TRUE;
  332.             }
  333.         }
  334. #endif
  335.         repr_tup = REPR(sym);
  336.         if (repr_tup != (Tuple)0) repr_tag = (int) repr_tup[1];     
  337.         if (repr_tup == (Tuple)0) { /* probably error condition */
  338.            putnum(ofile, "repr-type", -1);
  339.         }
  340.         else if (repr_tag == TAG_RECORD) {
  341.             putnum(ofile, "repr-type", repr_tag);
  342.                putnum(ofile,"repr-rec-size %d\n", (int) repr_tup[2]);
  343.             align_mod_tup = (Tuple) repr_tup[4];
  344.                putnum(ofile,"repr-rec-mod %d\n", (int) align_mod_tup[1]);
  345.             align_tup = (Tuple) align_mod_tup[2];
  346.             putnum(ofile, "repr-align-tup-size", tup_size(align_tup));
  347.             FORTUP (tup4=(Tuple), align_tup, ft1);
  348.                 putsymref(ofile,"repr-rec-align-1", (Symbol)tup4[1]);
  349.                 putnum(ofile,"repr-rec-align-2", (int) tup4[2]);
  350.                 putnum(ofile,"repr-rec-align-3", (int) tup4[3]);
  351.                 putnum(ofile,"repr-rec-align-4", (int) tup4[4]);
  352.             ENDFORTUP(ft1);
  353.         }
  354.         else if (repr_tag == TAG_ACCESS || 
  355.                  repr_tag == TAG_TASK) {
  356.             putnum(ofile, "repr-type", repr_tag);
  357.             putnum(ofile, "repr-size", (int)repr_tup[2]);
  358.             putnodref(ofile, "repr-storage-size", (Node) repr_tup[3]);
  359.         }
  360.         else {
  361.             putnum(ofile, "repr-type", repr_tag);
  362.             putnum(ofile, "repr-tup-size", (int)repr_tup[0]);
  363.             n = tup_size(repr_tup);
  364.             for (i = 2; i <= n; i++)
  365.                 putnum(ofile, "repr-info", (int) repr_tup[i]);
  366.             }
  367.         }
  368.     else {
  369.         putnum(ofile, "repr-type", -1);
  370.     }
  371. #ifdef TBSL
  372.     if (swap_private)
  373.         private_decls_swap(sym, vis_decl);
  374. #endif
  375. }
  376. static void putunt(IFILE *ofile, char *desc, unsigned int n)        /*;putunt*/
  377. {
  378.     /* like putnum, but verifies that argument positive 
  379.      * and also that it is 'small'. In particular this is used
  380.      * to guard for absurd unit numbers 
  381.      */
  382.     /* write integer (as a short) to output file */
  383.  
  384.     if (n > 200) chaos("putunt: absurd unit number");
  385.     putnum(ofile, desc, (int) n);
  386. }
  387.  
  388. static void putnval(IFILE *ofile, Node node)                    /*;putnval*/
  389. {
  390.     /* write out N_VAL field for node to AISFILE */
  391.  
  392.     int nk, ck, nv;
  393.     Const    con;
  394.     char    *s;
  395.     char    *inttos();
  396.     Rational    rat;
  397.     Tuple    tup, stup;
  398.     int        i, n;
  399.     int        *ui;
  400.     double    doub;
  401.  
  402.     nk = N_KIND(node);
  403.     s = N_VAL(node);
  404.     if (nk == as_simple_name || nk == as_int_literal || nk == as_real_literal
  405.       || nk == as_string_literal || nk == as_character_literal 
  406.       || nk == as_subprogram_stub_tr || nk == as_package_stub
  407.       || nk == as_task_stub) {
  408.         putstr(ofile, "nval-name", s);
  409.     }
  410.     else if (nk == as_line_no || nk == as_number || nk == as_predef) {
  411.         putnum(ofile, "nval-int", (int) s);
  412.     }
  413.     else if (nk == as_mode)  {
  414.         /* convert mode, indeed, the inverse of change made in astread*/
  415.         nv = (int) N_VAL(node);
  416.         putnum(ofile, "val-mode", nv);
  417.     }
  418.     else if (nk == as_ivalue ) {
  419.         con = (Const) N_VAL(node);
  420.         ck = con->const_kind;
  421.         putnum(ofile, "nval-const_kind", ck);
  422.         if (ck == CONST_INT)
  423.             putint(ofile, "nval-const-int-value", con->const_value.const_int);
  424.         else if (ck == CONST_REAL) {
  425.             doub = con->const_value.const_real;
  426.             fwrite((char *) &doub, sizeof(double), 1, ofile->fh_file);
  427.         }
  428.         else if (ck == CONST_UINT) {
  429.             ui = con->const_value.const_uint;
  430.             putuint(ofile, "nval-const-uint", ui);
  431.         }
  432.         else if (ck == CONST_OM) {
  433.             ; /* no further data needed if OM */
  434.         }
  435.         else if (ck == CONST_RAT) {
  436.             rat = con->const_value.const_rat;
  437.             putuint(ofile, "nval-const-rat-num", rat->rnum);
  438.             putuint(ofile, "nval-const-rat-den", rat->rden);
  439.         }
  440.         else if (ck == CONST_CONSTRAINT_ERROR) {
  441.             chaos("putnval: CONST_CONSTRAINT_ERROR");
  442.         }
  443.     }
  444.     else if (nk == as_terminate_alt) {
  445.         /*: terminate_statement (9)  nval is depth_count (int)*/
  446.         putnum(ofile, "nval-terminate-depth", (int) s);
  447.     }
  448.     else if (nk == as_string_ivalue) {
  449.         /* nval is tuple of integers */
  450.         tup = (Tuple) s;
  451.         n = tup_size(tup);
  452.         putnum(ofile, "nval-string-ivalue-size", n);
  453.         for (i = 1; i <= n; i++) {
  454.             putchr(ofile, "nval-string-ivalue", (int) tup[i]);
  455.         }
  456.     }
  457.     else if (nk == as_instance_tuple) {
  458.         stup = (Tuple) s;
  459.         if (stup != (Tuple)0) {
  460.             n = tup_size(stup);
  461.             if (n != 2)
  462.                 chaos("putnval: bad nval for instantiation");
  463.             putnum(ofile, "nval-instance-tupsize", n);
  464.             /* first component is instance map */
  465.             tup = ((Symbolmap)(stup)[1])->symbolmap_tuple;
  466.             n = tup_size(tup);
  467.             putnum(ofile, "nval-symbolmap-size", n);
  468.             for (i = 1; i <= n; i += 2) {
  469.                 putsymref(ofile, "symbolmap-1", (Symbol)tup[i]);
  470.                 putsymref(ofile, "symbolmap-2", (Symbol)tup[i+1]);
  471.             }
  472.             /* second component is needs_body flag */
  473.             putnum(ofile, "nval-flag", (int)(stup)[2]);
  474.         }
  475.         else putnum(ofile, "nval-instance-empty", 0);
  476.     }
  477.     /* need to handle following cases:
  478.      * (when do them, update libr and libs as well).
  479.      *     see also how handled for record_aggregates (gs: as_simple_name nodes
  480.      *             now attatched to n_list of as_record_aggregate )
  481.      * as_pragma: cf. process_pragma (2)
  482.      * as_array aggregate
  483.      * Need to review assignments of N_VAL in chapter 12, including:
  484.      *     as_generic: (cf. 12)
  485.      *     see subprog_instance (12) where N_VAL set to triple.
  486.      */
  487. }
  488.  
  489. static void putuint(IFILE *ofile, char *desc, int *pint)            /*;putuint*/
  490. {
  491.     int n;
  492.     n = pint[0];
  493.     putnum(ofile, "uint-size", n);
  494.     fwrite((char *) pint, sizeof(int), n+1, ofile->fh_file);
  495. }
  496.  
  497. static void putovl(IFILE *ofile, Symbol sym)                    /*;putovl*/
  498. {
  499.     int nat, n;
  500.     Set ovl;
  501.     Forset    fs1;
  502.     Forprivate_decls    fp;
  503.     Private_declarations    pd;
  504.     Symbol    s, s1, s2;
  505.  
  506.     nat = NATURE(sym);
  507.     ovl = OVERLOADS(sym);
  508.  
  509.     /* It is the private declarations for na_package and na_package_spec.
  510.      * (and also na_generic_package_spec)
  511.      * Otherwise it is a set of symbols:
  512.      *    na_aggregate  na_entry    na_function  na_function_spec
  513.      *    na_literal  na_op  na_procedure     na_procedure_spec
  514.      */
  515.     if (nat == na_block) {
  516.         /* ignore any overloads info for block - it is for internal use only */
  517.         return;
  518.     }
  519.     if (nat == na_package|| nat == na_package_spec
  520.       || nat == na_generic_package_spec || nat == na_generic_package
  521.       || nat == na_task_type || nat == na_task_obj) {
  522.         /* write out private declarations */
  523.         pd = (Private_declarations) ovl;
  524.         n = 0;
  525.         FORPRIVATE_DECLS(s1, s2, pd, fp);
  526.             n += 1;
  527.         ENDFORPRIVATE_DECLS(fp);
  528.         putnum(ofile, "ovl-private-decls-size", n);
  529.         FORPRIVATE_DECLS(s1, s2, pd, fp);
  530.             putsym(ofile, "ovl-pdecl-1-sym", s1);
  531.             putsym(ofile, "ovl-pdecl-2-sym", s2);
  532.         ENDFORPRIVATE_DECLS(fp);
  533.     }
  534.     else if (ovl != (Set)0) {
  535.         putnum(ofile, "ovl-set-size", set_size(ovl));
  536.         FORSET(s = (Symbol), ovl, fs1);
  537.             putsymref(ofile, "ovl-set-symref", s);
  538.         ENDFORSET(fs1);
  539.     }
  540.     else {
  541.         chaos("putovl surprising case!");
  542.     }
  543. }
  544.  
  545. static void putsig(IFILE *ofile, Symbol sym)                /*;putsig*/
  546. {
  547.     /* The signature field is used as follows:
  548.      * It is a symbol for:
  549.      *    na_access
  550.      * It is a node for
  551.      *    na_constant  na_in  na_inout
  552.      * It is also a node (always OPT_NODE) for na_out. For now we write this
  553.      * out even though it is not used. 
  554.      * It is a pair for na_array.
  555.      * It is a triple for na_enum.
  556.      * It is a triple for na_generic_function_spec na_generic_procedure_spec
  557.      * The first component is a tuple of pairs, each pair consisting of
  558.      * a symbol and a (default) node.
  559.      * The second component is a tuple of symbols.
  560.      * The third component is a node
  561.      * It is a tuple with four elements for na_generic_package_spec:
  562.      * the first is a tuple of pairs, with same for as for generic procedure.
  563.      * the second third, and fourth components are nodes.
  564.      * It is a 5-tuple for na_record.
  565.      * It is a constraint for na_subtype and na_type.
  566.      * It is a node for na_obj.
  567.      * Otherwise it is the signature for a procedure, namely a tuple
  568.      * of quadruples.
  569.      * Note however, that for a private type, the signature has the same
  570.      * form as for a record.
  571.      * For a subtype whose root type is an array, the signature has the
  572.      * same form as for an array.
  573.      * For task_type, task_type_spec, it is a tuple of nodes 
  574.      *  (created by the expander)
  575.      * For task_body it is a tuple (empty) to make it correspond to procedures.
  576.      *  (modified in expanded for as_task)
  577.      */
  578.  
  579.     int nat, i, n;
  580.     Tuple    sig, tup, tupent;
  581.     Symbol    s, s2;
  582.     Fortup    ft1;
  583.  
  584.     nat = NATURE(sym);
  585.     sig = SIGNATURE(sym);
  586.     switch (nat) {
  587.     case na_access:
  588.         /* access: signature is designated_type;*/
  589.         putsymref(ofile, "sig-access-symref", (Symbol) sig);
  590.         break;
  591.     case    na_array:
  592.         /* array: signature is pair [i_types, comp_type] where
  593.          * i_type is tuple of type names
  594.          */
  595. array_case:
  596.         putnum(ofile, "sig-array-i-types-size", tup_size((Tuple) sig[1]));
  597.         FORTUP(s = (Symbol), (Tuple) sig[1], ft1);
  598.             putsymref(ofile, "sig-array-i-types-type", s);
  599.         ENDFORTUP(ft1);
  600.         putsymref(ofile, "sig-array-comp-type", (Symbol) sig[2]);
  601.         break;
  602.     case    na_block:
  603.         /* block: miscellaneous information */
  604.         /* This information not needed externally*/
  605.         chaos("putsig: signature for block");
  606.         break;
  607.     case    na_constant:
  608.     case    na_in:
  609.     case    na_inout:
  610.     case    na_out:
  611.     case    na_discriminant:
  612.         putnodref(ofile, "sig-discriminant-nodref", (Node) sig);
  613.         break;
  614.     case    na_entry:
  615.     case    na_entry_family:
  616.     case    na_entry_former:
  617.         /* entry: list of symbols */
  618.     case    na_function:
  619.     case    na_function_spec:
  620.     case    na_literal:        /* is this for literals too? */
  621.     case    na_op:
  622.     case    na_procedure:
  623.     case    na_procedure_spec:
  624.     case    na_task_body:
  625.         putnum(ofile, "sig-tuple-size", tup_size(sig));
  626.         FORTUP(s = (Symbol), sig, ft1);
  627.             putsymref(ofile, "sig-tuple-symref", s);
  628.         ENDFORTUP(ft1);
  629.         break;
  630.     case    na_enum:
  631.         /* enum: tuple in form ['range', lo, hi]*/
  632.         /* we write this as two node references*/
  633.         putnodref(ofile, "sig-enum-low-nodref", (Node) sig[2]);
  634.         putnodref(ofile, "sig-enum-high-nodref", (Node) sig[3]);
  635.         break;
  636.     case    na_type:
  637.         /* treat private types way in same way as for records*/
  638.         s = TYPE_OF(sym);
  639.         s2 = TYPE_OF(root_type(sym));
  640.         if ( s == symbol_private || s == symbol_limited_private 
  641.           || s== symbol_incomplete || s2 == symbol_private 
  642.           || s2 == symbol_limited_private || s2 == symbol_incomplete
  643.           || (s != (Symbol)0 && NATURE(s) == na_record)
  644.             /* derived of private record or record */
  645.           || (s2 != (Symbol)0 && NATURE(s2) == na_record)) {
  646.             /* derived of derived of ... */
  647.             goto record_case;
  648.         }
  649.         if ((s != (Symbol)0 && NATURE(s) == na_access)
  650.           || (s2 != (Symbol)0 && NATURE(s2) == na_access)) {
  651. #ifdef TBSL
  652.             putsymref(ofile, "sig-access-symref", (Symbol) sig);
  653. #endif
  654.             putnum(ofile, "sig-type-is-access", 1);
  655.             break;
  656.         }
  657.         else {
  658.             putnum(ofile, "sig-type-is-access", 0);
  659.         }
  660.         n = tup_size(sig);
  661.         putnum(ofile, "sig-type-size", n);
  662.         putnum(ofile, "sig-type-constraint-kind", (int) sig[1]);
  663.         for (i = 2; i <= n; i++)
  664.             putnodref(ofile, "sig-type-nodref", (Node) sig[i]);
  665.         break;
  666.     case na_subtype:
  667.         n = tup_size(sig);
  668.         putnum(ofile, "sig-subtype-size", n);
  669.         if (is_array(sym)) { /* if constrained array */
  670.             putnum(ofile, "sig-constrained-array", CONSTRAINT_ARRAY);
  671.             goto array_case;
  672.         }
  673.         putnum(ofile, "sig-type-constraint-kind", (int) sig[1]);
  674.         if ((int)sig[1] == CONSTRAINT_DISCR) {
  675.             /* discriminant map */
  676.             tup = (Tuple) numeric_constraint_discr(sig);
  677.             n = tup_size(tup);
  678.             putnum(ofile, "sig-constraint-discrmap-size", n);
  679.             for (i = 1; i <= n; i += 2) {
  680.                 putsymref(ofile, "sig-constraint-discrmap-symref",
  681.                   (Symbol)tup[i]);
  682.                 putnodref(ofile, "sig-constraint-discrmap-nodref",
  683.                   (Node) tup[i+1]);
  684.             }
  685.         }
  686.         else if ((int)sig[1] == CONSTRAINT_ACCESS) {
  687.             putsymref(ofile, "sig-subtype-acc-symref", (Symbol)sig[2]);
  688.         }
  689.         else {
  690.             for (i = 2; i <= n; i++)
  691.                 putnodref(ofile, "sig-subtype-nodref", (Node) sig[i]);
  692.         }
  693.         break;
  694.     case    na_generic_function:
  695.     case    na_generic_procedure:
  696.     case    na_generic_function_spec:
  697.     case    na_generic_procedure_spec:
  698.         if (tup_size(sig) != 4)
  699.             chaos("putsig: bad signature for na_generic_procedure_spec");
  700.         /* tuple count known to be four, just put elements */
  701.         tup = (Tuple) sig[1];
  702.         /* the first component is a tuple of pairs, just write count
  703.          * and the values of the successive pairs 
  704.          */
  705.         n = tup_size(tup);
  706.         putnum(ofile, "sig-generic-size", n);
  707.         for (i = 1; i <= n; i++) {
  708.             tupent = (Tuple) tup[i];
  709.             putsymref(ofile, "sig-generic-symref", (Symbol) tupent[1]);
  710.             putnodref(ofile, "sig-generic-nodref", (Node) tupent[2]);
  711.         }
  712.         tup = (Tuple) sig[2];
  713.         n = tup_size(tup); /* symbol list */
  714.         putnum(ofile, "sig-generic-tup-size", n);
  715.         for (i = 1; i <= n; i++)
  716.             putsymref(ofile, "sig-generic-symbol-symref", (Symbol) tup[i]);
  717.         putnodref(ofile, "sig-generic-3-nodref", (Node) sig[3]);
  718.         /* the fourth component is tuple of symbols */
  719.         tup = (Tuple) sig[4];
  720.         n = tup_size(tup);
  721.         putnum(ofile, "sig-generic-contrain-size", n);
  722.         for (i = 1; i <= n; i++)
  723.             putsymref(ofile, "sig-generic-symref", (Symbol)tup[i]);
  724.         break;
  725.     case    na_generic_package_spec:
  726.     case    na_generic_package:
  727.         /* signature is tuple with five elements */
  728.         if (tup_size(sig) != 5)
  729.             chaos("putsig: bad signature for na_generic_package_spec");
  730.         tup = (Tuple) sig[1];
  731.         /* the first component is a tuple of pairs, just write count
  732.          * and the values of the successive pairs 
  733.          */
  734.         n = tup_size(tup);
  735.         putnum(ofile, "sig-generic-tup-size", n);
  736.         for (i = 1; i <= n; i++) {
  737.             tupent = (Tuple) tup[i];
  738.             putsymref(ofile, "sig-generic-symref", (Symbol) tupent[1]);
  739.             putnodref(ofile, "sig-generic-nodref", (Node) tupent[2]);
  740.         }
  741.         /* the second third, and fourth components are just nodes */
  742.         putnodref(ofile, "sig-generic-node-2", (Node) sig[2]);
  743.         putnodref(ofile, "sig-generic-node-3", (Node) sig[3]);
  744.         putnodref(ofile, "sig-generic-node-4", (Node) sig[4]);
  745.         /* the fifth component is tuple of symbols */
  746.         tup = (Tuple) sig[5];
  747.         n = tup_size(tup);
  748.         putnum(ofile, "sig-generic-contrain-size", n);
  749.         for (i = 1; i <= n; i++)
  750.             putsymref(ofile, "sig-generic-symref", (Symbol)tup[i]);
  751.         break;
  752.     case    na_record:
  753.         /* the signature is tuple with five components:
  754.          * [node, node, tuple of symbols, declaredmap, node]
  755.          * NOTE: we do not write component count - 5 assumed 
  756.          */
  757. record_case:
  758.         putnodref(ofile, "sig-record-1-nodref", (Node) sig[1]);
  759.         putnodref(ofile, "sig-record-2-nodref", (Node) sig[2]);
  760.         tup = (Tuple) sig[3];
  761.         n = tup_size(tup);
  762.         putnum(ofile, "sig-record-3-size", n);
  763.         for (i = 1; i <= n; i++)
  764.             putsymref(ofile, "sig-record-3-symref", (Symbol) tup[i]);
  765.         putdcl(ofile, (Declaredmap) sig[4]);
  766.         putnodref(ofile, "sig-record-5-nodref", (Node) sig[5]);
  767.         break;
  768.     case    na_void:
  769.         /* special case assume entry for $used, in which case is tuple
  770.          * of symbols
  771.          */
  772.         if (streq(ORIG_NAME(sym), "$used") ) {
  773.             n = tup_size(sig);
  774.             putnum(ofile, "sig-$used-size", n);
  775.             for (i = 1; i <= n; i++)
  776.                 putsymref(ofile, "sig-$used-symref", (Symbol) sig[i]);
  777.         }
  778.         else {
  779. #ifdef DEBUG
  780.             zpsym(sym);
  781. #endif
  782.             chaos("putsig: na_void, not $used");
  783.         }
  784.         break;
  785.     case    na_obj:
  786.         putnodref(ofile, "sig-obj-nodref", (Node) sig);
  787.         break;
  788.     case na_task_type:
  789.     case na_task_type_spec:
  790.         /* a tuple of nodes */
  791.         n = tup_size(sig);
  792.         putnum(ofile, "task-type-spec-size", n);
  793.         for (i = 1; i <= n; i++)
  794.             putnodref(ofile, "sig-task-nodref", (Node)sig[i]);
  795.         break;
  796.     default:
  797. #ifdef DEBUG
  798.         printf("putsig: default error\n");
  799.         zpsym(sym);
  800. #endif
  801.         chaos("putsig: default");
  802.     }
  803. }
  804.  
  805. static void putsym(IFILE *ofile, char *desc, Symbol sym)            /*;putsym*/
  806. {
  807.     /* write description for symbol sym to output file */
  808.  
  809.     struct f_symbol_s fs;
  810.     int nat;
  811.     Tuple    sig, tup;
  812.     Set     set;
  813.     Symbol    s, s2;
  814.     Fortup    ft1;
  815.  
  816.     nat = NATURE(sym);
  817. #ifdef DEBUG
  818.     if (trapss>0 && S_SEQ(sym) == trapss && S_UNIT(sym) == trapsu) traps(sym);
  819. #endif
  820.     fs.f_symbol_nature = nat;
  821.     fs.f_symbol_seq = S_SEQ(sym);
  822.     fs.f_symbol_unit = S_UNIT(sym);
  823.     s = TYPE_OF(sym);
  824.     if (s == (Symbol)0) {
  825.         fs.f_symbol_type_of_seq = 0;
  826.         fs.f_symbol_type_of_unit = 0;
  827.     }
  828.     else {
  829.         fs.f_symbol_type_of_seq = S_SEQ(s);
  830.         fs.f_symbol_type_of_unit = S_UNIT(s);
  831.     }
  832.     sig = SIGNATURE(sym);
  833.     if (sig == (Tuple)0) {
  834.         fs.f_symbol_signature = 0;
  835.     }
  836.     else {
  837.         /* signature field not relevant for na_block externally */
  838.         fs.f_symbol_signature = 1;
  839.         if (nat == na_block) fs.f_symbol_signature = 0;
  840.     }
  841.     s = SCOPE_OF(sym);
  842.     if (s == (Symbol)0) {
  843.         fs.f_symbol_scope_of_seq = 0;
  844.         fs.f_symbol_scope_of_unit = 0;
  845.     }
  846.     else {
  847.         fs.f_symbol_scope_of_seq = S_SEQ(s);
  848.         fs.f_symbol_scope_of_unit = S_UNIT(s);
  849.     }
  850.     s = ALIAS(sym);
  851.     if (s == (Symbol)0) {
  852.         fs.f_symbol_alias_seq = 0;
  853.         fs.f_symbol_alias_unit = 0;
  854.     }
  855.     else {
  856.         fs.f_symbol_alias_seq = S_SEQ(s);
  857.         fs.f_symbol_alias_unit = S_UNIT(s);
  858.     }
  859.     set = OVERLOADS(sym);
  860.     if (set == (Set)0) {
  861.         fs.f_symbol_overloads = 0;
  862.     }
  863.     else {
  864.         fs.f_symbol_overloads = 1;
  865.         if (nat == na_block) fs.f_symbol_overloads = 0;
  866.     }
  867.     if (DECLARED(sym) != (Declaredmap)0) {
  868.         fs.f_symbol_declared = 1;
  869.     }
  870.     else {
  871.         fs.f_symbol_declared = 0;
  872.     }
  873.     fs.f_symbol_type_attr = TYPE_ATTR(sym);
  874.     s = TYPE_OF(sym);
  875.     if (NATURE(sym) == na_type ) {
  876.         s2 = TYPE_OF(root_type(sym));
  877.         if (s == symbol_private || s == symbol_limited_private 
  878.           || s == symbol_incomplete || s2 == symbol_private 
  879.           || s2 == symbol_limited_private || s2 == symbol_incomplete
  880.           /* I think the following test is true in case of derived of record 
  881.            * and therefore that the code is wrong. JC
  882.            */
  883.           || (s != (Symbol)0 && NATURE(s) == na_record)
  884.           /* derived of private record or record */
  885.           || (s2 != (Symbol)0 && NATURE(s2) == na_record)) {
  886.             /* derived of derived of ... */
  887.             fs.f_symbol_type_attr |= TA_ISPRIVATE;
  888.         }
  889.     }
  890.     /* The following fields are for use by the code generator only */
  891.     fs.f_symbol_misc = (MISC(sym) != (char *)0);
  892.     fs.f_symbol_type_kind = TYPE_KIND(sym);
  893.     fs.f_symbol_type_size = TYPE_SIZE(sym);
  894.     s = INIT_PROC(sym);
  895.     if (s == (Symbol)0) {
  896.         fs.f_symbol_init_proc_seq = 0;
  897.         fs.f_symbol_init_proc_unit = 0;
  898.     }
  899.     else if (!is_type(sym)) {
  900.         /* case of formal_decl_tree for subprogram specs */
  901.         fs.f_symbol_init_proc_seq = N_SEQ((Node)s);
  902.         fs.f_symbol_init_proc_unit = N_UNIT((Node)s);
  903.     }
  904.     else {
  905.         fs.f_symbol_init_proc_seq = S_SEQ(s);
  906.         fs.f_symbol_init_proc_unit = S_UNIT(s);
  907.     }
  908.     tup = ASSOCIATED_SYMBOLS(sym);
  909.     if (tup == (Tuple)0) {
  910.         fs.f_symbol_assoc_list = 0;
  911.     }
  912.     else {
  913.         if (nat == na_in || nat == na_out || nat == na_inout) {
  914.             /* avoid writing associated symbols for functions and subprograms
  915.              * as these need not be written  ds 9-aug-85
  916.              */
  917.             fs.f_symbol_assoc_list = 0;
  918.         }
  919.         else {
  920.             fs.f_symbol_assoc_list = 1 + tup_size(tup);
  921.         }
  922.     }
  923.     fs.f_symbol_s_segment = S_SEGMENT(sym);
  924.     fs.f_symbol_s_offset = S_OFFSET(sym);
  925.  
  926.     fwrite((char *) &fs, sizeof(f_symbol_s), 1, ofile->fh_file);
  927.     putstr(ofile, "orig-name", ORIG_NAME(sym));
  928.     /* process overloads separately due to variety of cases */
  929.     /* treat na_enum case separately */
  930.     if (fs.f_symbol_overloads) {
  931.         if(fs.f_symbol_nature == na_enum)
  932.             putlitmap(ofile, sym);
  933.         else
  934.             putovl(ofile, sym);
  935.     }
  936.     if (fs.f_symbol_declared)
  937.         putdcl(ofile, DECLARED(sym));
  938.     /* signature */
  939.     if (fs.f_symbol_signature)
  940.         putsig(ofile, sym);
  941.  
  942.     putmisc(ofile, sym);
  943.  
  944.     /* write out associated symbols of necessary */
  945.     if (fs.f_symbol_assoc_list > 1) {
  946.         tup = ASSOCIATED_SYMBOLS(sym);
  947.         FORTUP(s = (Symbol), tup, ft1)
  948.             putsymref(ofile, "assoc-symbol-symref", s);
  949.         ENDFORTUP(ft1);
  950.     }
  951.     putrepr(ofile, sym);
  952. }
  953.  
  954. void putsymref(IFILE *ofile, char *desc, Symbol sym)        /*;putsymref*/
  955. {
  956.     if (sym == (Symbol)0) {
  957.         putpos(ofile, "symref-seq", 0);
  958.         putpos(ofile, "symref-unt", 0);
  959.     }
  960.     else {
  961. #ifdef DEBUG
  962.         if(trapss>0 && trapss == S_SEQ(sym) && trapsu == S_UNIT(sym))traps(sym);
  963. #endif
  964.         putpos(ofile, "symref-seq", S_SEQ(sym));
  965.         putpos(ofile, "symref-unt", S_UNIT(sym));
  966.     }
  967. }
  968.  
  969. static void putudecl(IFILE *ofile, int ui)                        /*;putudecl*/
  970. {
  971.     int i, n, cn, ci;
  972.     Tuple    tup, cent, ctup, cntup;
  973.     Unitdecl    ud;
  974.  
  975.     ud = (Unitdecl) pUnits[ui]->aisInfo.unitDecl;
  976.     putsym(ofile, "ud-unam", ud->ud_unam);
  977.     put_unit_unam(ofile, ud->ud_unam);
  978.     /* context */
  979.     ctup = (Tuple) ud->ud_context;
  980.     if (ctup == (Tuple)0)
  981.         n = 0;
  982.     else
  983.         n = tup_size(ctup)+1;
  984.     putnum(ofile, "decl-context-size", n);
  985.     if (n > 1) {
  986.         n -= 1;
  987.         for (i = 1; i <= n; i++) {
  988.             cent = (Tuple) ctup[i];
  989.             putnum(ofile, "decl-ctup-1", (int) cent[1]);
  990.             cntup = (Tuple) cent[2]; /* 2nd component is tuple of strings */
  991.             cn = tup_size(cntup);
  992.             putnum(ofile, "decl-cntup-size", cn);
  993.             for (ci = 1; ci <= cn; ci++)
  994.                 putstr(ofile, "decl-tupstr-str", cntup[ci]);
  995.         }
  996.     }
  997.     /* unit_nodes */
  998.     tup = ud->ud_nodes;
  999.     n = tup_size(tup);
  1000.     putnum(ofile, "decl-ud-nodes-size", n);
  1001.     for (i = 1; i <= n; i++) {
  1002.         putnodref(ofile, "decl-nodref", (Node) tup[i]);
  1003.     }
  1004.     /* tuple of symbol table pointers */
  1005.     tup = ud->ud_symbols;
  1006.     if (tup == (Tuple)0)
  1007.         n = 0;
  1008.     else
  1009.         n = tup_size(tup)+1;
  1010.     putnum(ofile, "decl-symbol-tuple-size", n);
  1011.     if (n>1) {
  1012.         n -= 1;
  1013.         for (i = 1; i <= n; i++) {
  1014.             /*putsymref(ofile, tup[i]);*/
  1015.             /* write full symbol def */
  1016.             putsym(ofile, "decl-symref", (Symbol) tup[i]);
  1017.         }
  1018.     }
  1019.  
  1020.     /* decscopes - tuple of scopes */
  1021.     tup = ud->ud_decscopes;
  1022.     if (tup == (Tuple)0)
  1023.         n = 0;
  1024.     else
  1025.         n = tup_size(tup)+1;
  1026.     putnum(ofile, "decl-descopes-size", n);
  1027.     if (n > 1) {
  1028.         n -= 1;
  1029.         for (i = 1; i <= n; i++) {
  1030.             putsym(ofile, "decl-descopes-symref", (Symbol) tup[i]);
  1031.         }
  1032.     }
  1033.     /* decmaps - tuple of declared maps */
  1034.     tup = ud->ud_decmaps;
  1035.     if (tup == (Tuple)0)
  1036.         n = 0;
  1037.     else
  1038.         n = tup_size(tup)+1;
  1039.     putnum(ofile, "decmaps-tuple-size", n);
  1040.     if (n>1) {
  1041.         n -= 1;
  1042.         for (i = 1; i <= n; i++)
  1043.             putdcl(ofile, (Declaredmap) tup[i]);
  1044.     }
  1045.     /* oldvis - tuple of unit names */
  1046.     tup = ud->ud_oldvis;
  1047.     if (tup == (Tuple)0)
  1048.         n = 0;
  1049.     else
  1050.         n = tup_size(tup)+1;
  1051.     putnum(ofile, "vis", n);
  1052.     if (n>1) {
  1053.         n -= 1;
  1054.         for (i = 1; i <= n; i++) {
  1055.             putstr(ofile, "vis-str", tup[i]);
  1056.         }
  1057.     }
  1058.     return;
  1059. }
  1060.  
  1061. long write_ais(int ui)                                        /*;write_ais*/
  1062. {
  1063.     /* Writes information from the current compilation to
  1064.      * 'file', restructuring the separate compilation maps
  1065.      * to improve the readability of the AIS code.
  1066.      */
  1067.  
  1068.     int     i, n, symbols, is_main;
  1069.     long    begpos, genoff, endpos;
  1070.     Tuple    tup;
  1071.     Set        set;
  1072.     Forset    fs1;
  1073.     IFILE    *ofile;
  1074.     struct unit *pUnit = pUnits[ui];
  1075.  
  1076.     ofile = AISFILE;
  1077.     begpos = write_next(ofile); /* start record*/
  1078.     putstr(ofile, "unit-name", pUnit->name); /* unit name */
  1079.     putnum(ofile, "unit-number", ui); /* unit number */
  1080.     genoff = iftell(ofile);
  1081.     /* offset to code generator information */
  1082.     putlong(ofile, "code-gen-offset", 0L);
  1083.     is_main = streq(unit_name_type(pUnit->name), "ma");
  1084.     if (!is_main) {
  1085.         putnum(ofile, "seq-symbol-n", seq_symbol_n);
  1086.         /* write out the number of tree node for this unit */
  1087.         putnum(ofile, "seq-node-n", seq_node_n);
  1088.         symbols = seq_symbol_n;
  1089.         pUnit->aisInfo.numberSymbols = symbols;
  1090.  
  1091.         /* ELABORATE PRAGMA INFO */
  1092.         tup = (Tuple) pUnit->aisInfo.pragmaElab;
  1093.         n = tup_size(tup);
  1094.         putnum(ofile, "pragma-info-size", n);
  1095.         for (i = 1; i <= n; i++)
  1096.             putstr(ofile, "pragma-str", tup[i]);        /* pragma info*/
  1097.         /* UNIT_DECL */
  1098.         putudecl(ofile, ui);
  1099.         /* now write out info for each symbol in compilation unit.
  1100.          * perhaps we need write out only those referenced in prior
  1101.          * items read in, but for now we write out all for sake of
  1102.          * completeness and to assist debugging     (ds 19-oct-84)
  1103.          */
  1104.         /* PRE_COMP */
  1105.         set = (Set) pUnit->aisInfo.preComp; /* pre_comp info*/
  1106.         n = set_size(set);
  1107.         putnum(ofile, "precomp-size", n);
  1108.         FORSET(n = (int), set, fs1);
  1109.             putnum(ofile, "precomp-value", n);
  1110.         ENDFORSET(fs1);
  1111.         ifseek(ofile, "seek-to-end", 0l, 2); /* position back at end*/
  1112.         tup = tup_new(symbols);
  1113.         for (i = 1; i <= symbols; i++)
  1114.             tup[i] = (char *) seq_symbol[i];
  1115.         pUnit->aisInfo.symbols = (char *) tup;
  1116.     }
  1117.     endpos = iftell(ofile); /* get current offset (end of sem info) */
  1118.     /* position to word to get end offset */
  1119.     ifseek(ofile, "seek-to-gen-offset", genoff, 0);
  1120.     putlong(ofile, "end-pos", endpos);
  1121.     ifseek(ofile, "seek-to-end", 0L, 2); /* move back to end of file */
  1122.     write_end(ofile, begpos);
  1123.     return begpos;
  1124. }
  1125.  
  1126. void write_stub(Stubenv ev, char *stub_name, char *ext)            /*;write_stub*/
  1127. {
  1128.     /* Writes information from the stub environment for stub si to the end of
  1129.      * STUBFILE. 
  1130.      * First open STUBFILE if this is first stub and therefore STUBFILE is not 
  1131.      * opened yet. The file extension ext is st1 for semantics phase and st2 for
  1132.      * the code generator phase.
  1133.      */
  1134.  
  1135.     int        i, j, k, n, m;
  1136.     long    begpos;
  1137.     Tuple    tup, tup2, tup3;
  1138.     int        cn, ci;
  1139.     Tuple    cent, cntup;
  1140.     IFILE    *ofile;
  1141.  
  1142.     if (STUBFILE == (IFILE *)0)
  1143.         STUBFILE = ifopen(AISFILENAME, ext, "w", 0);
  1144.     ofile = STUBFILE;
  1145.     begpos = write_next(ofile); /* start record*/
  1146.     putstr(ofile, "stub-name", stub_name); /* stub name */
  1147.  
  1148.     /* SCOPE STACKS */
  1149.     tup = (Tuple) ev->ev_scope_st;
  1150.     n = tup_size(tup);
  1151.     putnum(ofile, "scope-stack-size", n);
  1152.     for (i = 1; i <= n; i++) {
  1153.         tup2 = (Tuple) tup[i];
  1154.         putsymref(ofile, "scope-stack-symref", (Symbol) tup2[1]);
  1155.         for (j = 2; j <= 4; j++) {
  1156.             tup3 = (Tuple) tup2[j];
  1157.             m = tup_size(tup3);
  1158.             putnum(ofile, "scope-stack-m", m);
  1159.             for (k = 1; k <= m; k++)
  1160.                 putsymref(ofile, "scope-stack-m-symref", (Symbol) tup3[k]);
  1161.         }
  1162.     }
  1163.     putsymref(ofile, "ev-unit-name-symref", ev->ev_unit_unam);
  1164.     putdcl(ofile, ev->ev_decmap);
  1165.  
  1166.     /* unit_nodes */
  1167.     tup = ev->ev_nodes;
  1168.     n = tup_size(tup);
  1169.     putnum(ofile, "ev-nodes-size", n);
  1170.     for (i = 1; i <= n; i++) {
  1171.         putnodref(ofile, "ev-nodes-nodref", (Node) tup[i]);
  1172.     }
  1173.  
  1174.     /* context */
  1175.     tup = (Tuple) ev->ev_context;
  1176.     if (tup == (Tuple)0)
  1177.         n = 0;
  1178.     else
  1179.         n = tup_size(tup)+1;
  1180.     putnum(ofile, "stub-context-size", n);
  1181.     if (n>1) {
  1182.         n -= 1;
  1183.         for (i = 1; i <= n; i++) {
  1184.             cent = (Tuple) tup[i];
  1185.             putnum(ofile, "stub-cent-1", (int) cent[1]);
  1186.             cntup = (Tuple) cent[2]; /* 2nd component is tuple of strings */
  1187.             cn = tup_size(cntup);
  1188.             putnum(ofile, "stub-cent-2-size", cn);
  1189.             for (ci = 1; ci <= cn; ci++)
  1190.                 putstr(ofile, "stub-cent-2-str", cntup[ci]);
  1191.         }
  1192.     }
  1193.     /* tuple of symbol table pointers */
  1194.     tup = ev->ev_open_decls;
  1195.     if (tup == (Tuple)0)
  1196.         n = 0;
  1197.     else
  1198.         n = tup_size(tup)+1;
  1199.     putnum(ofile, "ev-decls-ref-size", n);
  1200.     /* write symbol table references so that they can be read by routine 
  1201.      * read_stub_short bypassing reading of full symbol definitions 
  1202.      */
  1203.     if (n>1) {
  1204.         n -= 1;
  1205.         for (i = 1; i <= n; i++) {
  1206.             /* write symbol ref */
  1207.             putsymref(ofile, "decls-ref", (Symbol) tup[i]);
  1208.         }
  1209.     }
  1210.     /* tuple of symbol table pointers */
  1211.     tup = ev->ev_open_decls;
  1212.     if (tup == (Tuple)0)
  1213.         n = 0;
  1214.     else
  1215.         n = tup_size(tup)+1;
  1216.     putnum(ofile, "ev-open-decls-size", n);
  1217.     if (n>1) {
  1218.         n -= 1;
  1219.         for (i = 1; i <= n; i++) {
  1220.             /*putsymref(ofile, tup[i]);*/
  1221.             /* write full symbol def */
  1222.             putsym(ofile, "open-decls-sym", (Symbol) tup[i]);
  1223.         }
  1224.     }
  1225.     putnum(ofile, "stub-current-level", ev->ev_current_level);
  1226.     tup = (Tuple) ev->ev_relay_set;
  1227.     if (tup == (Tuple)0)
  1228.         n = 0;
  1229.     else
  1230.         n = tup_size(tup)+1;
  1231.     putnum(ofile, "ev-stub-relay_set-size", n);
  1232.     if (n>1) {
  1233.         n -= 1;
  1234.         for (i = 1; i <= n; i++) {
  1235.             putsymref(ofile, "relay_set_sym", (Symbol) tup[i]);
  1236.             /* write ref to symbol  */
  1237.         }
  1238.     }
  1239.     tup = (Tuple) ev->ev_dangling_relay_set;
  1240.     if (tup == (Tuple)0)
  1241.         n = 0;
  1242.     else
  1243.         n = tup_size(tup)+1;
  1244.     putnum(ofile, "ev-dangling_relay_set-size", n);
  1245.     if (n>1) {
  1246.         n -= 1;
  1247.         for (i = 1; i <= n; i++) {
  1248.             putnum(ofile, "dangl_relay_ent", (int) tup[i]);
  1249.         }
  1250.     }
  1251.     write_end(ofile, begpos);
  1252. }
  1253.  
  1254. void write_tre(int uindex, int rootseq, char *reach)            /*;write_tre*/
  1255. /* rootseq - sequence number of root node*/
  1256. /* uindex - unit number */
  1257. {
  1258.     long    *rara, dpos;
  1259.     int i, nodes;
  1260.     Node    node;
  1261.     Tuple    tup;
  1262.     long    begpos;
  1263.     IFILE    *ofile;
  1264.     struct unit *pUnit = pUnits[uindex];
  1265.  
  1266.     nodes = seq_node_n;
  1267.     /* save position of start of data */
  1268.     /* write out all nodes if reach is null ptr */
  1269.     ofile = TREFILE;
  1270.     begpos = write_next(ofile);
  1271.     putstr(ofile, "unit-name", pUnit->name); /* unit name */
  1272.     putnum(ofile, "unit-number", uindex); /* unit number */
  1273.     putnum(ofile, "node-count", nodes);
  1274.     pUnit->treInfo.nodeCount = nodes;
  1275.     /* allocate space for node directory and write to file, saving position*/
  1276.     rara = (long *)ecalloct((unsigned) nodes+1, sizeof(long), "write-tre-rara");
  1277.     dpos = iftell(ofile);
  1278.     fwrite((char *) rara, sizeof(long), nodes+1, ofile->fh_file);
  1279.     putnum(ofile, "root-seq", rootseq);
  1280.     for (i = 1; i <= nodes; i++) {
  1281.         if (reach != (char *) 0 && reach[i] != '1') continue;
  1282.         node = (Node) seq_node[i];
  1283.         if (node == (Node)0) continue; /* do not write null nodes */
  1284.         rara[i] = iftell(ofile);
  1285.         putnod(ofile, "unit-node", node);
  1286.     }
  1287.     /* rewrite node list now that available */
  1288.     ifseek(ofile, "seek-node-list", dpos, 0);
  1289.     fwrite((char *) rara, sizeof(long), nodes+1, ofile->fh_file);
  1290.     ifseek(ofile, "seek-to-end", 0l, 2); /* position back at end*/
  1291.     /* ????? pUnit->treInfo.tupleAllocated = (char *) rara; */
  1292.     /* save address of node list */
  1293.     tup = tup_new(nodes);
  1294.     for (i = 1; i <= nodes; i++)
  1295.         tup[i] = (char *) seq_node[i];
  1296.     pUnit->treInfo.tableAllocated = (char *) tup;
  1297.     write_end(ofile, begpos);
  1298. }
  1299.  
  1300. static long write_next(IFILE *ofile)                            /*;write_next*/
  1301. {
  1302.     long    startpos;
  1303.     ifseek(ofile, "write-next-seek-to-end", 0L, 2); /* move to end of file */
  1304.     startpos = iftell(ofile); /* note position */
  1305.     putlong(ofile, "start-next-unit", startpos);
  1306.     return startpos;
  1307. }
  1308.  
  1309. void write_end(IFILE *ofile, long startpos)            /*;write_end*/
  1310. {
  1311.     long pos;
  1312.  
  1313.     ifseek(ofile, "write-end-seek-to-end", 0L, 2); /*move to end of file */
  1314.     pos = iftell(ofile); /* get offset of end of file*/
  1315.     ofile->fh_units_end = pos;
  1316.     /* move to start of pointer word */
  1317.     ifseek(ofile, "write-end-seek-pointer", startpos, 0);
  1318.     /* update pointer to next record */
  1319.     putlong(ofile, "write-end-next-unit", pos);
  1320.     ifseek(ofile, "write-end-seek-to-end", 0L, 2); /* move to end of file */
  1321. }
  1322.  
  1323. static void put_unit_unam(IFILE *ofile, Symbol sym)            /*;put_unit_unam*/
  1324. {
  1325.     /*  
  1326.      * Write the full symbol definitions of the associated symbol field of the
  1327.      * unit name symbol. This is needed since when binding is done we want to
  1328.      * load the symbols from this field which represent the procedures to 
  1329.      * elaborate packages. If a filed entry is undefined we write out the
  1330.      * definition of the OPT_NAME symbol so that we always have 3 entries.
  1331.      */
  1332.  
  1333.     Tuple    tup;
  1334.     int    i;
  1335.  
  1336.     tup = ASSOCIATED_SYMBOLS(sym);
  1337.     if (tup == (Tuple)0) tup = tup_new(3);
  1338.     for (i = 1; i <= 3; i++) {
  1339.         if (tup[i] != (char *)0) putsym(ofile, "ud-assoc-sym", (Symbol)tup[i]);
  1340.         else putsym(ofile, "ud-assoc-sym", OPT_NAME);
  1341.     }
  1342. }
  1343.  
  1344. void cleanup_files()                                        /*;cleanup_files*/
  1345. {
  1346.     /* This procedure removes all files in the library that are not
  1347.      * attached to currently active compilation units.
  1348.      */
  1349. #ifdef BSD
  1350.     DIR *dirp;
  1351.     struct direct *dp;
  1352. #endif
  1353.  
  1354. #ifdef SYSTEM_V
  1355.     register int    fd;
  1356.     struct direct    entry;
  1357. #endif 
  1358.  
  1359. #ifdef IBM_PC
  1360.     char *emalloc();
  1361.     char *strjoin();
  1362.     char *dname;
  1363.     struct find_t dos_fileinfo;
  1364. #endif
  1365.  
  1366.     char *s1,*s2;
  1367.     int  unit;
  1368.     Tuple active_files;
  1369.  
  1370.     /* create a list of active files (those for which there is at least
  1371.      * one non-obsolete unit in it.)
  1372.      */
  1373.     active_files = tup_new1(FILENAME);
  1374.  
  1375.     for (unit = 1; unit <= unit_numbers; unit++) {
  1376.         struct unit *pUnit = pUnits[unit];
  1377.            if (streq(pUnit->libInfo.obsolete, "ok")) {
  1378.              if (!tup_memstr(pUnit->libInfo.fname, active_files)) {
  1379.                 active_files = tup_with(active_files, pUnit->libInfo.fname);
  1380.             }
  1381.          }
  1382.     }
  1383.  
  1384. #ifdef BSD
  1385.     dirp = opendir(LIBRARY_PREFIX);
  1386.     /* Loop through the directory and remove any files of the form #.* if
  1387.      * # is not an active file.
  1388.      */
  1389.     for (dp = readdir(dirp); dp != NULL; dp = readdir(dirp)) {
  1390.            s1 = strjoin(dp->d_name,"");
  1391.            s2 = strchr(s1,'.');
  1392.            if (s2 == (char *)0) s2 = s1;
  1393.            *s2 = '\0';
  1394.            /* ignore files that don't have a dot in it. */
  1395.            if (!strlen(s1)) continue;
  1396.            /* only consider of files of the form xxx.yyy where yyy is one of the 
  1397.             * Ada/Ed extensions 
  1398.             */
  1399.            s2++; /* file extension */
  1400.            if ((streq(s2,"trc")|| streq(s2,"axq") || streq(s2,"st1")
  1401.           || streq(s2,"st2") || streq(s2,"exe"))
  1402.           && !tup_memstr(s1, active_files)) {
  1403.               ifdelete(dp->d_name);
  1404.            }
  1405.     }
  1406.  
  1407.     /* remove the current aic file */
  1408.     ifdelete(strjoin(AISFILENAME,".aic"));
  1409.  
  1410. #endif
  1411. #ifdef SYSTEM_V
  1412.     fd = open(LIBRARY_PREFIX,O_RDONLY);
  1413.     /* Loop through the directory and remove any files of the form #.* if
  1414.      * # is not an active file.
  1415.      */
  1416.     while (read(fd,&entry,sizeof(entry)) > 0) {
  1417.            if (entry.d_ino == 0) continue;
  1418.            s1 = strjoin(entry.d_name, "");
  1419.            s2 = strchr(s1,'.');
  1420.            if (s2 == (char *)0) s2 = s1;
  1421.            *s2 = '\0';
  1422.            /* ignore files that don't have a dot in it. */
  1423.            if (!strlen(s1)) continue;
  1424.            /* only consider of files of the form xxx.yyy where yyy is one of the 
  1425.             * Ada/Ed extensions 
  1426.             */
  1427.            s2++; /* file extension */
  1428.            if ((streq(s2, "trc")|| streq(s2, "axq") || streq(s2, "st1")
  1429.           || streq(s2, "st2")) && !tup_memstr(s1, active_files)) {
  1430.               ifdelete(entry.d_name);
  1431.            }
  1432.     }
  1433.  
  1434.     /* remove the current aic file */
  1435.     ifdelete(strjoin(AISFILENAME, ".aic"));
  1436. #endif
  1437. #ifdef IBM_PC
  1438.     /* Loop through the directory and remove any files of the form #.* if
  1439.      * # is not an active file.
  1440.      */
  1441.     errno = 0;
  1442.  
  1443.     dname = emalloc(strlen(LIBRARY_PREFIX) + 5);
  1444.     strcpy(dname, LIBRARY_PREFIX);
  1445.     strcat(dname,"\\*.*");
  1446.     for (_dos_findfirst(dname, _A_NORMAL, &dos_fileinfo);;
  1447.       _dos_findnext(&dos_fileinfo)) {
  1448.         if (errno) break;
  1449.         s1 = strjoin(dos_fileinfo.name, "");
  1450.         s2 = strchr(s1, '.');
  1451.         if (s2 == (char *)0) s2 = s1;
  1452.         *s2 = '\0';
  1453.         /* ignore files that don't have a dot in it. */
  1454.         if (!strlen(s1)) continue;
  1455.         /* only consider of files of the form xxx.yyy where yyy is one of the 
  1456.          * Ada/Ed extensions 
  1457.          */
  1458.         s2++; /* file extension */
  1459.         /* On PC, directory folds file names to upper case */
  1460.         if ((streq(s2, "TRC")|| streq(s2, "AXQ") ||streq(s2, "ST1")
  1461.           || streq(s2, "ST2")) && !tup_memstr(s1, active_files)) {
  1462.             ifdelete(dos_fileinfo.name);
  1463.         }
  1464.     }
  1465.  
  1466.     /* remove the current aic file */
  1467.     ifdelete(strjoin(AISFILENAME, ".AIC"));
  1468. #endif
  1469. }
  1470.  
  1471. void ifdelete(char *fname)                                        /*;ifdelete*/
  1472. {
  1473.     char *tname;
  1474.  
  1475.     /* allow room for library prefix, file name and suffix */
  1476.     tname = emalloc((unsigned) (strlen(LIBRARY_PREFIX) + strlen(fname) + 3));
  1477.     if (strlen(LIBRARY_PREFIX)) { /* prepend library prefix if present */
  1478.         strcpy(tname, LIBRARY_PREFIX);
  1479. #ifdef IBM_PC
  1480.         strcat(tname, "\\");
  1481. #endif
  1482. #ifdef BSD
  1483.         strcat(tname, "/");
  1484. #endif
  1485. #ifdef SYSTEM_V
  1486.         strcat(tname, "/");
  1487. #endif
  1488.         strcat(tname, fname);
  1489.     }
  1490.     else {
  1491.         strcpy(tname, fname); /* copy name if no prefix */
  1492.     }
  1493. #ifdef BSD
  1494.     unlink(tname);
  1495. #endif
  1496. #ifdef SYSTEM_V
  1497.     unlink(tname);
  1498. #endif
  1499. #ifdef IBM_PC
  1500.     unlink(tname);
  1501. #endif
  1502.     efree(tname);
  1503. }
  1504.